home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_Tix.idb / usr / freeware / lib / tix4.1 / WinFile.tcl.z / WinFile.tcl
Encoding:
Text File  |  1999-01-26  |  13.6 KB  |  649 lines
  1. # WinFile.tcl --
  2. #
  3. #    MS Window file access portibility routines.
  4. #
  5. # Copyright (c) 1996, Expert Interface Technologies
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. #
  10.  
  11. proc tixInitFileCmpt:Win {} {
  12.     global tixPriv tcl_platform
  13.  
  14.     if {$tcl_platform(osVersion) >= 4.0} {
  15.     set tixPriv(isWin95) 1
  16.     } else {
  17.     set tixPriv(isWin95) 0
  18.     }
  19.     if $tixPriv(isWin95) {
  20.     set tixPriv(WinPrefix) xx\\xx
  21.     } else {
  22.     set tixPriv(WinPrefix) xx
  23.     }
  24.  
  25. #----------------------------------------------------------------------
  26. #
  27. #        MS Windows
  28. #
  29. #----------------------------------------------------------------------
  30.  
  31. # splits a Windows directory into its hierarchical components
  32. #
  33. proc tixFSSplit {vpath} {
  34.     global tixPriv
  35.  
  36.     set path ""
  37.     if $tixPriv(isWin95) {
  38.     if ![string compare $vpath xx] {
  39.         lappend path [list xx     "Desktop"     "C:\\Windows\\Desktop" ]
  40.         return $path
  41.     }
  42.     if ![string compare $vpath xx\\xx] {
  43.         lappend path [list xx     "Desktop"     "C:\\Windows\\Desktop" ]
  44.         lappend path [list xx\\xx "My Computer" "C:\\"]
  45.         return $path
  46.     }
  47.  
  48.     set prefix "xx\\xx"
  49.     if ![regsub {^xx\\xx\\} $vpath "" dir] {
  50.         if [regsub {^xx\\} $vpath "" dir] {
  51.         lappend path [list xx     "Desktop"     "C:\\Windows\\Desktop" ]
  52.         set v "xx"
  53.         set p "C:\\Windows\\Desktop"
  54.         foreach d [split $dir \\] {
  55.             append v \\$d
  56.             append p \\$d
  57.             lappend path [list $v $d $p]
  58.         }
  59.         return $path
  60.         }
  61.     }
  62.     regsub {:$} $dir :/ dir
  63.     lappend path [list xx     "Desktop"     "C:\\Windows\\Desktop" ]
  64.     lappend path [list xx\\xx "My Computer" "C:\\"]
  65.     } else {
  66.     if ![string compare $vpath xx] {
  67.         lappend path [list xx     "My Computer" "C:\\"]
  68.         return $path
  69.     }
  70.     lappend path [list xx     "My Computer" "C:\\"]
  71.  
  72.     set prefix xx
  73.     regsub {^xx\\} $vpath "" dir
  74.     regsub {:$} $dir :/ dir
  75.     }
  76.  
  77.     if ![string compare $dir ""] {
  78.     return $path
  79.     }
  80.     if [string compare [file pathtype $dir] "absolute"] {
  81.     error "$dir must be an absolute path"
  82.     }
  83.  
  84.     set dirs [file split $dir]
  85.     set p ""
  86.     foreach d $dirs {
  87.     set p [file join $p $d]
  88.     regsub -all / $p \\ p
  89.     set vpath $prefix\\$p
  90.     regsub {[\\]$} $vpath "" vpath
  91.     regsub {:/$} $d ":" d
  92.     lappend path [list $vpath $d $p]
  93.     }
  94.  
  95.     return $path
  96. }
  97.  
  98. # returns true if $dir is an valid path (not equal to "")
  99. #
  100. proc tixFSValid {dir} {
  101.     return [expr ![string compare $dir ""]]
  102. }
  103.  
  104. # tixFSIntName
  105. #
  106. #    Returns the "virtual path" of a filename
  107. #
  108. proc tixFSIntName {dir} {
  109.     global tixPriv
  110.  
  111.     if ![string compare $dir ""] {
  112.     if $tixPriv(isWin95) {
  113.         return "xx\\xx"
  114.     } else {
  115.         return xx
  116.     }
  117.     }
  118.         
  119.     if [string compare [file pathtype $dir] "absolute"] {
  120.     error "$dir must be an absolute path"
  121.     }
  122.  
  123.     if $tixPriv(isWin95) {
  124.         set vpath "xx\\xx\\$dir"
  125.     } else {
  126.         set vpath "xx\\$dir"
  127.     }
  128.     regsub {:/$} $vpath ":" vpath
  129.     regsub {[\\]$} $vpath "" vpath
  130.     return $vpath
  131. }
  132.  
  133. proc tixFSIntJoin {dir sub} {
  134.     set vpath $dir\\$sub
  135.     regsub -all {\\\\} $vpath \\ vpath
  136.     regsub {:/$} $vpath : vpath
  137.     regsub {[\\]$} $vpath "" vpath
  138.     return $vpath
  139. }
  140.  
  141. proc tixFSJoin {dir sub} {
  142.     set p [file join $dir $sub]
  143.     regsub -all / $p \\ p
  144.     return $p
  145. }
  146.  
  147. proc tixFSResolveName {p} {
  148.     regsub -all / $p \\ p
  149.     if [regexp {:([^\\]|$)} $p] {
  150.     regsub : $p :\\ p
  151.     }
  152.     return $p
  153. }
  154.  
  155. # dir:        Make a listing of this directory
  156. # showSubDir:    Want to list the subdirectories?
  157. # showFile:    Want to list the non-directory files in this directory?
  158. # showPrevDir:    Want to list ".." as well?
  159. # showHidden:    Want to list the hidden files? (%% is ignored)
  160. #
  161. # return value:    a list of files and/or subdirectories
  162. #
  163. proc tixFSListDir {vpath showSubDir showFile showPrevDir showHidden {pattern ""}} {
  164.     global tixPriv
  165.     set appPWD [pwd]
  166.     set list ""
  167.  
  168.     if $tixPriv(isWin95) {
  169.     if ![string compare $vpath xx] {
  170.         set dir C:\\Windows\\Desktop
  171.         if {$showSubDir} {
  172.         lappend list xx:
  173.         }
  174.     } elseif ![string compare $vpath xx\\xx] {
  175.         if {$showSubDir} {
  176.         return [tixFSGetDrives]
  177.         } else {
  178.         return ""
  179.         }
  180.     } else {
  181.         if ![regsub {^xx\\xx\\} $vpath "" dir] {
  182.         regsub {^xx\\} $vpath C:\\Windows\\Desktop\\ dir
  183.         }
  184.         regsub {:$} $dir :\\ dir
  185.     }
  186.     } else {
  187.     if ![string compare $vpath xx] {
  188.         if {$showSubDir} {
  189.         return [tixFSGetDrives]
  190.         } else {
  191.         return ""
  192.         }
  193.     }
  194.  
  195.     regsub {^xx\\} $vpath "" dir
  196.     regsub {:$} $dir :\\ dir
  197.     }
  198.  
  199.     if [catch {cd $dir} err] {
  200.     # The user has entered an invalid directory
  201.     # %% todo: prompt error, go back to last succeed directory
  202.     cd $appPWD
  203.     return ""
  204.     }
  205.  
  206.     if {$pattern == ""} {
  207.     set pattern "*"
  208.     }
  209.  
  210.     if [catch {set names [lsort [eval glob -nocomplain $pattern]]} err] {
  211.     # Cannot read directory
  212.     # %% todo: show directory permission denied
  213.     cd $appPWD
  214.     return ""
  215.     }
  216.  
  217.     catch {
  218.     # We are catch'ing, just in case the "file" command returns unexpected
  219.     # errors
  220.     #
  221.     foreach fname $names {
  222.         if {![string compare . $fname]} {
  223.         continue
  224.         }
  225.         if {![string compare ".." $fname]} {
  226.         continue
  227.         }
  228.         if [file isdirectory $fname] {
  229.         if $showSubDir {
  230.             lappend list [file tail $fname]
  231.         }
  232.         } else {
  233.         if $showFile {
  234.             lappend list [file tail $fname]
  235.         }
  236.         }
  237.     }
  238.     }
  239.     cd $appPWD
  240.  
  241.     if {$showSubDir && $showPrevDir && $dir != "/"} {
  242.     return [tixFSMakeList $vpath $dir [lsort [concat .. $list]]]
  243.     } else {
  244.     return [tixFSMakeList $vpath $dir $list]
  245.     }
  246. }
  247.  
  248. proc tixFSMakeList {vpath dir list} {
  249.     global tixPriv
  250.  
  251.     if $tixPriv(isWin95) {
  252.     set prefix xx\\xx
  253.     } else {
  254.     set prefix xx
  255.     }
  256.     set l ""
  257.     foreach file $list {
  258.     if ![string compare $file xx:] {
  259.          lappend l [list xx\\xx "My Computer" "C:\\"]
  260.     } else {
  261.         set path [tixFSJoin $dir $file]
  262.         lappend l [list $vpath\\$file $file $path]
  263.     }
  264.     }
  265.  
  266.     return $l
  267. }
  268.  
  269. proc tixFSSep {} {
  270.     return "\\"
  271. }
  272.  
  273. proc tixFSGetDrives {} {
  274.     global tixPriv
  275.  
  276.     if [info exists tixPriv(drives)] {
  277.     return $tixPriv(drives)
  278.     } else {
  279.     set drives [list A: B:]
  280.     foreach d {c d e f g h i j k l m n o p q r s t u v w x y z} {
  281.         if [file exists $d:\\] {
  282.         lappend drives [string toupper $d:]
  283.         }
  284.     }
  285.  
  286.     set tixPriv(drives) ""
  287.     foreach d $drives {
  288.          lappend tixPriv(drives) [list $tixPriv(WinPrefix)\\$d $d $d\\]
  289.     }
  290.     }
  291.     return $tixPriv(drives)
  292. }
  293.  
  294. #----------------------------------------------------------------------
  295. #
  296. #        OBSOLETE
  297. #
  298. #----------------------------------------------------------------------
  299.  
  300.  
  301.  
  302. # Directory separator
  303. #
  304. proc tixDirSep {} {
  305.     return "\\"
  306. }
  307.  
  308. # returns the "root directory" of this operating system
  309. #
  310. # out:    intName
  311. proc tixRootDir {} {
  312.     return "/"
  313. }
  314.  
  315. # is an absoulte path only if it starts with a baclskash
  316. # or starts with "<drive letter>:"
  317. #
  318. # in: nativeName
  319. #
  320. proc tixIsAbsPath {nativeName} {
  321.     set c [string index $nativeName 0]
  322.     if {$c == "\\"} {
  323.     return 1
  324.     }
  325.  
  326.     if {[string compare [string toupper $c] A] < 0} {
  327.     return 0
  328.     }
  329.     if {[string compare [string toupper $c] Z] > 0} {
  330.     return 0
  331.     }
  332.     if {[string index $nativeName 1] != ":"} {
  333.     return 0
  334.     }
  335.     return 1
  336. }
  337.  
  338. # returns <drive>:
  339. #
  340. proc tixWinGetFileDrive {nativeName} {
  341.     set c [string index $nativeName 0]
  342.     if {$c == "\\"} {
  343.     return [string toupper [string range [pwd] 0 1]]
  344.     }
  345.  
  346.     if {[string compare [string toupper $c] A] < 0} {
  347.     return [string toupper [string range [pwd] 0 1]]
  348.     }
  349.     if {[string compare [string toupper $c] Z] > 0} {
  350.     return [string toupper [string range [pwd] 0 1]]
  351.     }
  352.     if {[string index $nativeName 1] != ":"} {
  353.     return [string toupper [string range [pwd] 0 1]]
  354.     }
  355.     return [string toupper [string range $nativeName 0 1]]
  356. }
  357.  
  358. # returns the absolute pathname of the file 
  359. # (not including the drive letter or the first backslash)
  360. #
  361. # [tixWinGetFileDrive]\\[tixWinGetFilePath] gives the complete
  362. # drive and pathname
  363. #
  364. proc tixWinGetFilePath {nativeName} {
  365.     set c [string index $nativeName 0]
  366.     if {$c == "\\"} {
  367.     return ""
  368.     }
  369.  
  370.     if {[string compare [string toupper $c] A] < 0} {
  371.     return [tixWinGetPathFromDrive $nativeName]
  372.     }
  373.     if {[string compare [string toupper $c] Z] > 0} {
  374.     return [tixWinGetPathFromDrive $nativeName]
  375.     }
  376.     if {[string index $nativeName 1] != ":"} {
  377.     return [tixWinGetPathFromDrive $nativeName]
  378.     }
  379.     if {[string index $nativeName 2] != "\\"} {
  380.         regexp {[A-z]:} $nativeName drive
  381.     regsub {[A-z]:} $nativeName "" path
  382.     return [tixWinGetPathFromDrive $path $drive]
  383.     }
  384.  
  385.     regsub {[A-z]:[\\]} $nativeName "" path
  386.     return $path
  387. }
  388.  
  389. proc tixWinCurrentDrive {} {
  390.     return [string range [pwd] 0 1]
  391. }
  392.  
  393. proc tixWinGetPathFromDrive {path {drive ""}} {
  394.     if {$drive == ""} {
  395.         set drive [tixWinCurrentDrive]
  396.     }
  397.  
  398.     #
  399.     # %% currently TCL (7.5b3) does not tell what the current path
  400.     #    on a particular drive is
  401.  
  402.     return $path
  403. }
  404.  
  405. #
  406. #
  407. # nativeName:    native filename used in this OS, comes from the user or
  408. #        application programmer
  409. # defParent:    (intName) if the filename is not an absolute path,
  410. #        treat it as a subfolder of $defParent
  411. #        (must be an intName, must be absolute)
  412. proc tixFileIntName {nativeName {defParent ""}} {
  413.     if {![tixIsAbsPath $nativeName]} {
  414.         if {$defParent != ""} {
  415.         if {[string index $defParent 0] != "/"} {
  416.             error "Tix toolkit error: \"$defParent\" is not an absolute internal file name"
  417.         }
  418.         set path [tixSubFolder $defParent $nativeName]
  419.     } else {
  420.         set path $nativeName
  421.     }
  422.     } else {
  423.     set path /[tixWinGetFileDrive $nativeName]\\[tixWinGetFilePath $nativeName]
  424.     }
  425.  
  426.     set intName ""
  427.     foreach name [tixFileSplit $path] {
  428.     set intName [tixSubFolder $intName $name]
  429.     }
  430.  
  431.     return $intName
  432. }
  433.  
  434. # in:    internal name
  435. # out:    native name
  436. proc tixNativeName {intName {mustBeAbs 1}} {
  437.     if {[string index $intName 0] != "/"} {
  438.         if {$mustBeAbs} {
  439.             error "Tix internal error: \"$intName\" is not an intName"
  440.     } else {
  441.         return $intName
  442.     }
  443.     }
  444.     if {$intName == "/"} {
  445.         return C:\\
  446.     }
  447.     regsub {/[\\]} $intName "" nativeName
  448.     if {[string length $nativeName] == 2} {
  449.         return $nativeName\\
  450.     } else {
  451.         return $nativeName
  452.     }
  453. }
  454.  
  455. # how a filename should be displayed
  456. # 
  457. # e.g. /\C: becomes C:\\
  458. #      /\   becomes "My Computer"
  459. #      /\C:\\Windows is Windows
  460. proc tixFileDisplayName {intName} {
  461.     if {[string index $intName 0] != "/"} {
  462.         error "Tix internal error: \"$intName\" is not an intName"
  463.     }
  464.  
  465.     if {$intName == "/"} {
  466.         return "My Computer"
  467.     }
  468.  
  469.     regsub {/[\\]} $intName "" nativeName
  470.  
  471.     if {[string length $nativeName] == 2} {
  472.         return [string toupper $nativeName\\]
  473.     } else {
  474.         return [file tail $nativeName]
  475.     }
  476. }
  477.  
  478. # in:    internal name
  479. # out:    a list of paths
  480. proc tixFileSplit {intName} {
  481.  
  482.     set l ""
  483.     foreach n [split $intName /\\] {
  484.     if {$n == ""} {
  485.         continue
  486.     }
  487.     if {$n == "."} {
  488.         continue
  489.     }
  490.  
  491.     lappend l $n
  492.     }
  493.     
  494.  
  495.     while 1 {
  496.     set idx [lsearch $l ".."]
  497.     if {$idx == -1} {
  498.         break;
  499.     }
  500.     set l [lreplace $l [expr $idx -1] $idx]
  501.     }
  502.  
  503.  
  504.     if {[string index $intName 0] == "/"} {
  505.     return [concat "/" $l]
  506.     } else {
  507.     return $l
  508.     }
  509. }
  510.  
  511. # parent, sub:    intName
  512. #
  513. proc tixSubFolder {parent sub} {
  514.     if {$parent == ""} {
  515.     return $sub
  516.     }
  517.     return $parent\\$sub
  518. }
  519.  
  520. proc tixWinGetDrives {} {
  521.     global tixPriv
  522.  
  523.     if [info exists tixPriv(drives)] {
  524.     return $tixPriv(drives)
  525.     } else {
  526.     set tixPriv(drives) {A: B:}
  527.         foreach d {c e d f g h i j k l m n o p q r s t u v w x y z} {
  528.         if [file exists $d:] {
  529.         lappend tixPriv(drives) [string toupper $d:]
  530.         }
  531.         }
  532.     }
  533.     return $tixPriv(drives)
  534. }
  535.  
  536. # dir:        Make a listing of this directory
  537. # showSubDir:    Want to list the subdirectories?
  538. # showFile:    Want to list the non-directory files in this directory?
  539. # showPrevDir:    Want to list ".." as well?
  540. # showHidden:    Want to list the hidden files? (%% is ignored)
  541. #
  542. # return value:    a list of files and/or subdirectories
  543. #
  544. proc tixListDir {dir showSubDir showFile showPrevDir showHidden {pattern ""}} { 
  545.     set appPWD [pwd]
  546.  
  547.     if {$dir == "/"} {
  548.     if {$showSubDir} {
  549.         return [tixWinGetDrives]
  550.         } else {
  551.         return ""
  552.     }
  553.     }
  554.  
  555.     if [catch {cd [tixNativeName $dir]} err] {
  556.     # The user has entered an invalid directory
  557.     # %% todo: prompt error, go back to last succeed directory
  558.     cd $appPWD
  559.     return ""
  560.     }
  561.  
  562.     if {$pattern == ""} {
  563.     set pattern "*"
  564.     }
  565.  
  566.     if [catch {set names [lsort [eval glob -nocomplain $pattern]]} err] {
  567.     # Cannot read directory
  568.     # %% todo: show directory permission denied
  569.     cd $appPWD
  570.     return ""
  571.     }
  572.  
  573.     set list ""
  574.     catch {
  575.     # We are catch'ing, just in case the "file" command returns unexpected
  576.     # errors
  577.     #
  578.      foreach fname $names {
  579.         if {![string compare . $fname]} {
  580.         continue
  581.         }
  582.          if {![string compare ".." $fname]} {
  583.             continue
  584.         }
  585.         if [file isdirectory $fname] {
  586.         if $showSubDir {
  587.             lappend list [file tail $fname]
  588.         }
  589.         } else {
  590.         if $showFile {
  591.             lappend list [file tail $fname]
  592.         }
  593.         }
  594.     }
  595.     }
  596.     cd $appPWD
  597.  
  598.     if {$showSubDir && $showPrevDir && $dir != "/"} {
  599.     return [lsort [concat .. $list]]
  600.     } else {
  601.         return $list
  602.     }
  603. }
  604.  
  605. proc tixVerifyFile {file} {
  606.     return [tixFileIntName $file]
  607. }
  608.  
  609. proc tixFilePattern {args} {
  610.     if {[lsearch $args allFiles] != -1} {
  611.     return *
  612.     }
  613.     return *
  614. }
  615.  
  616. }
  617.  
  618. # tixWinFileEmu --
  619. #
  620. #    Emulates a MS Windows file system environemnt inside Unix
  621. #
  622. proc tixWinFileEmu {} {
  623.     cd /mnt/c
  624.     rename pwd __pwd
  625.     rename cd  __cd
  626.     proc EmuConvert {path} {
  627.     if [regsub ^/mnt/c/ $path c:/ path] {
  628.         return $path
  629.     }
  630.     if [regsub ^/mnt/d/ $path d:/ path] {
  631.         return $path
  632.     }
  633.     if [regsub ^/mnt/c\$ $path c:/ path] {
  634.         return $path
  635.     }
  636.     if [regsub ^/mnt/d\$ $path d:/ path] {
  637.         return $path
  638.     }
  639.     return c:/windows
  640.     }
  641.  
  642.     proc pwd {} {
  643.     return [EmuConvert [__pwd]]
  644.     }
  645.     proc glob {args} {
  646.  
  647.     }
  648. }
  649.